{
-- |
-- Module      :  Cryptol.Parser
-- Copyright   :  (c) 2013-2016 Galois, Inc.
-- License     :  BSD3
-- Maintainer  :  cryptol@galois.com
-- Stability   :  provisional
-- Portability :  portable

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Trustworthy #-}
module Cryptol.Parser
  ( parseModule
  , parseProgram, parseProgramWith
  , parseExpr, parseExprWith
  , parseDecl, parseDeclWith
  , parseDecls, parseDeclsWith
  , parseLetDecl, parseLetDeclWith
  , parseRepl, parseReplWith
  , parseSchema, parseSchemaWith
  , parseModName, parseHelpName
  , parseImpName
  , ParseError(..), ppError
  , Layout(..)
  , Config(..), defaultConfig
  , guessPreProc, PreProc(..)
  ) where

import           Control.Applicative as A
import           Data.Maybe(fromMaybe)
import           Data.List.NonEmpty ( NonEmpty(..), cons )
import           Data.Text(Text)
import qualified Data.Text as T
import           Control.Monad(liftM2,msum)

import Cryptol.Parser.AST
import Cryptol.Parser.Position
import Cryptol.Parser.LexerUtils hiding (mkIdent)
import Cryptol.Parser.Token
import Cryptol.Parser.ParserUtils
import Cryptol.Parser.Unlit(PreProc(..), guessPreProc)
import Cryptol.Utils.RecordMap(RecordMap)

import Paths_cryptol
}

%token
  NUM         { $$@(Located _ (Token (Num   {}) _))}
  FRAC        { $$@(Located _ (Token (Frac  {}) _))}
  STRLIT      { $$@(Located _ (Token (StrLit {}) _))}
  CHARLIT     { $$@(Located _ (Token (ChrLit {}) _))}

  IDENT       { $$@(Located _ (Token (Ident [] _) _))}
  QIDENT      { $$@(Located _ (Token  Ident{}     _))}

  SELECTOR    { $$@(Located _ (Token  (Selector _) _))}

  'include'   { Located $$ (Token (KW KW_include)   _)}
  'import'    { Located $$ (Token (KW KW_import)    _)}
  'as'        { Located $$ (Token (KW KW_as)        _)}
  'hiding'    { Located $$ (Token (KW KW_hiding)    _)}
  'private'   { Located $$ (Token (KW KW_private)   _)}
  'parameter' { Located $$ (Token (KW KW_parameter) _)}
  'property'  { Located $$ (Token (KW KW_property)  _)}
  'infix'     { Located $$ (Token (KW KW_infix)     _)}
  'infixl'    { Located $$ (Token (KW KW_infixl)    _)}
  'infixr'    { Located $$ (Token (KW KW_infixr)    _)}

  'type'      { Located $$ (Token (KW KW_type   ) _)}
  'newtype'   { Located $$ (Token (KW KW_newtype) _)}
  'enum'      { Located $$ (Token (KW KW_enum) _)}
  'deriving'  { Located $$ (Token (KW KW_deriving) _)}
  'module'    { Located $$ (Token (KW KW_module ) _)}
  'submodule' { Located $$ (Token (KW KW_submodule ) _)}
  'where'     { Located $$ (Token (KW KW_where  ) _)}
  'let'       { Located $$ (Token (KW KW_let    ) _)}
  'if'        { Located $$ (Token (KW KW_if     ) _)}
  'then'      { Located $$ (Token (KW KW_then   ) _)}
  'else'      { Located $$ (Token (KW KW_else   ) _)}
  'case'      { Located $$ (Token (KW KW_case) _)}
  'of'        { Located $$ (Token (KW KW_of) _)}
  'interface' { Located $$ (Token (KW KW_interface) _)}
  'x'         { Located $$ (Token (KW KW_x)       _)}
  'down'      { Located $$ (Token (KW KW_down)    _)}
  'by'        { Located $$ (Token (KW KW_by)      _)}

  'primitive' { Located $$ (Token (KW KW_primitive) _)}
  'constraint'{ Located $$ (Token (KW KW_constraint) _)}
  'foreign'   { Located $$ (Token (KW KW_foreign) _)}
  'Prop'      { Located $$ (Token (KW KW_Prop) _)}

  '['         { Located $$ (Token (Sym BracketL) _)}
  ']'         { Located $$ (Token (Sym BracketR) _)}
  '<-'        { Located $$ (Token (Sym ArrL    ) _)}
  '..'        { Located $$ (Token (Sym DotDot  ) _)}
  '...'       { Located $$ (Token (Sym DotDotDot) _)}
  '..<'       { Located $$ (Token (Sym DotDotLt) _)}
  '..>'       { Located $$ (Token (Sym DotDotGt) _)}
  '|'         { Located $$ (Token (Sym Bar     ) _)}
  '<'         { Located $$ (Token (Sym Lt      ) _)}
  '>'         { Located $$ (Token (Sym Gt      ) _)}

  '('         { Located $$ (Token (Sym ParenL  ) _)}
  ')'         { Located $$ (Token (Sym ParenR  ) _)}
  ','         { Located $$ (Token (Sym Comma   ) _)}
  ';'         { Located $$ (Token (Sym Semi    ) _)}
  -- '.'         { Located $$ (Token (Sym Dot     ) _)}
  '{'         { Located $$ (Token (Sym CurlyL  ) _)}
  '}'         { Located $$ (Token (Sym CurlyR  ) _)}
  '<|'        { Located $$ (Token (Sym TriL    ) _)}
  '|>'        { Located $$ (Token (Sym TriR    ) _)}
  '='         { Located $$ (Token (Sym EqDef   ) _)}
  '`'         { Located $$ (Token (Sym BackTick) _)}
  ':'         { Located $$ (Token (Sym Colon   ) _)}
  '->'        { Located $$ (Token (Sym ArrR    ) _)}
  '=>'        { Located $$ (Token (Sym FatArrR ) _)}
  '\\'        { Located $$ (Token (Sym Lambda  ) _)}
  '_'         { Located $$ (Token (Sym Underscore ) _)}


  'v{'        { Located $$ (Token (Virt VCurlyL)  _)}
  'v}'        { Located $$ (Token (Virt VCurlyR)  _)}
  'v;'        { Located $$ (Token (Virt VSemi)    _)}

  '+'         { Located $$ (Token (Op Plus)  _)}
  '*'         { Located $$ (Token (Op Mul)   _)}
  '^^'        { Located $$ (Token (Op Exp)   _)}

  '-'         { Located $$ (Token (Op Minus) _)}
  '~'         { Located $$ (Token (Op Complement) _)}

  '#'         { Located $$ (Token (Op Hash) _)}
  '@'         { Located $$ (Token (Op At) _)}

  OP          { $$@(Located _ (Token (Op (Other [] _)) _))}
  QOP         { $$@(Located _ (Token (Op  Other{}   )  _))}

  DOC         { $$@(Located _ (Token (White DocStr) _)) }

%name top_module top_module
%name program program
%name programLayout program_layout
%name expr    expr
%name decl    decl
%name decls   decls
%name declsLayout decls_layout
%name letDecl let_decl
%name repl    repl
%name schema  schema
%name modName modName
%name impName impName
%name helpName help_name
%tokentype { Located Token }
%monad { ParseM }
%lexer { lexerP } { Located _ (Token EOF _) }

{- If you add additional operators, please update the corresponding
   tables in the pretty printer. -}

%right '->'
%right '#'
%%


top_module :: { [Module PName] }
  : mbDoc 'module' module_def {% mkTopMods $1 $3 }
  | 'v{' vmod_body 'v}'       {% mkAnonymousModule $2 }
  | mbDoc 'interface' 'module' modName 'where' 'v{' sig_body 'v}'
                              { mkTopSig $1 $4 $7 }

module_def :: { Module PName }

  : modName 'where'
      'v{' vmod_body 'v}'                     { mkModule $1 $4 }

  | modName '=' impName 'where'
      'v{' vmod_body 'v}'                     { mkModuleInstanceAnon $1 $3 $6 }

  | modName '=' impName '{' modInstParams '}' { mkModuleInstance $1 $3 $5 }


modInstParams            :: { ModuleInstanceArgs PName }
  : modInstParam            { DefaultInstArg $1 }
  | namedModInstParams      { NamedInstArgs $1 }

namedModInstParams                       :: { [ ModuleInstanceNamedArg PName ] }
  : namedModInstParam                         { [$1] }
  | namedModInstParams ',' namedModInstParam  { $3 : $1 }

namedModInstParam          :: { ModuleInstanceNamedArg PName }
  : ident '=' modInstParam    { ModuleInstanceNamedArg $1 $3 }

modInstParam               :: { Located (ModuleInstanceArg PName) }
  : impName                   { fmap ModuleArg $1 }
  | 'interface' ident         { fmap ParameterArg $2 }
  | '_'                       { Located { thing    = AddParams
                                        , srcRange = $1 } }

vmod_body                  :: { [TopDecl PName] }
  : vtop_decls                { reverse $1 }
  | {- empty -}               { [] }



-- inverted
imports1                  :: { [ Located (ImportG (ImpName PName)) ] }
  : imports1 'v;' import     { $3 : $1 }
  | imports1 ';'  import     { $3 : $1 }
  | import                   { [$1] }


import                     :: { Located (ImportG (ImpName PName)) }
  : mbDoc 'import' impName optInst mbAs mbImportSpec optImportWhere
                              {% mkImport $2 $3 $4 $5 $6 $7 $1 }
  | mbDoc 'import' impNameBT mbAs mbImportSpec {% mkBacktickImport $2 $3 $4 $5 $1 }

optImportWhere             :: { Maybe (Located [Decl PName]) }
  : 'where' whereClause       { Just $2 }
  | {- empty -}               { Nothing }

optInst                    :: { Maybe (ModuleInstanceArgs PName) }
  : '{' modInstParams '}'     { Just $2 }
  | {- empty -}               { Nothing }


impName                    :: { Located (ImpName PName) }
  : 'submodule' qname         { ImpNested `fmap` $2 }
  | modName                   { ImpTop `fmap` $1 }

impNameBT                  :: { Located (ImpName PName) }
  : 'submodule' '`' qname     { ImpNested `fmap` $3 }
  | '`' modName               { ImpTop `fmap` $2 }




mbAs                       :: { Maybe (Located ModName) }
  : 'as' modName              { Just $2 }
  | {- empty -}               { Nothing }

mbImportSpec               :: { Maybe (Located ImportSpec) }
  : mbHiding '(' name_list ')'{ Just Located
                                  { srcRange = case $3 of
                                      { [] -> emptyRange
                                      ; xs -> rCombs (map srcRange xs) }
                                  , thing    = $1 (reverse (map thing $3))
                                  } }
  | {- empty -}               { Nothing }

name_list                  :: { [LIdent] }
  : name_list ',' var         { fmap getIdent $3 : $1 }
  | var                       { [fmap getIdent $1]    }
  | {- empty -}               { []                    }

mbHiding                   :: { [Ident] -> ImportSpec }
  : 'hiding'                  { Hiding }
  | {- empty -}               { Only   }

program                    :: { Program PName }
  : top_decls                 { Program (reverse $1) }
  | {- empty -}               { Program [] }

program_layout             :: { Program PName }
  : 'v{' vtop_decls 'v}'      { Program (reverse $2) }
  | 'v{''v}'                  { Program []           }

top_decls                  :: { [TopDecl PName]  }
  : top_decl ';'              { $1         }
  | top_decls top_decl ';'    { $2 ++ $1   }

vtop_decls                 :: { [TopDecl PName]  }
  : vtop_decl                 { $1       }
  | vtop_decls 'v;' vtop_decl { $3 ++ $1 }
  | vtop_decls ';'  vtop_decl { $3 ++ $1 }

vtop_decl               :: { [TopDecl PName] }
  : decl                   { [exportDecl Nothing   Public $1]                 }
  | doc decl               { [exportDecl (Just $1) Public $2]                 }
  | 'include' STRLIT       {% (return . Include) `fmap` fromStrLit $2         }
  | mbDoc 'property' name iapats '=' expr
                           { [exportDecl $1 Public (mkProperty $3 $4 $6)]     }
  | mbDoc 'property' name       '=' expr
                           { [exportDecl $1 Public (mkProperty $3 [] $5)]     }
  | mbDoc newtype          { [exportNewtype Public $1 $2]                     }
  | mbDoc enum             { [exportEnum Public $1 $2]                        }
  | prim_bind              { $1                                               }
  | foreign_bind           { $1                                               }
  | private_decls          { $1                                               }
  | mbDoc 'interface' 'constraint' type {% mkInterfaceConstraint $1 $4 }
  | parameter_decls        { [ $1 ]                                       }
  | mbDoc 'submodule' module_def
                           {% ((:[]) . exportModule $1) `fmap` mkNested $3 }

  | mbDoc sig_def          { [mkSigDecl $1 $2]  }
  | mod_param_decl         { [DModParam $1] }
  | import                 { [DImport $1] }


sig_def ::                 { (Located PName, Signature PName) }
  : 'interface' 'submodule' name 'where' 'v{' sig_body 'v}'
                           { ($3, $6) }

sig_body                 :: { Signature PName }
  : par_decls               {% mkInterface [] $1 }
  | imports1 'v;' par_decls {% mkInterface (reverse $1) $3 }
  | imports1 ';'  par_decls {% mkInterface (reverse $1) $3 }


mod_param_decl ::          { ModParam PName }
  : mbDoc
   'import' 'interface'
    impName mbAs           { ModParam { mpSignature = $4
                                      , mpAs        = fmap thing $5
                                      , mpName      = mkModParamName $4 $5
                                      , mpDoc       = $1
                                      , mpRenaming  = mempty } }


top_decl                :: { [TopDecl PName] }
  : decl                   { [Decl (TopLevel {tlExport = Public, tlValue = $1 })] }
  | 'include' STRLIT       {% (return . Include) `fmap` fromStrLit $2             }
  | prim_bind              { $1                                                   }

private_decls           :: { [TopDecl PName] }
  : 'private' 'v{' vtop_decls 'v}'
                           { changeExport Private (reverse $3) }
  | doc 'private' 'v{' vtop_decls 'v}'
                           {% privateDocedDecl $1 $4 }

prim_bind               :: { [TopDecl PName] }
  : mbDoc 'primitive' name  ':' schema       { mkPrimDecl $1 $3 $5 }
  | mbDoc 'primitive' '(' op ')' ':' schema  { mkPrimDecl $1 $4 $7 }
  | mbDoc 'primitive' 'type' schema ':' kind {% mkPrimTypeDecl $1 $4 $6 }

foreign_bind            :: { [TopDecl PName] }
  : mbDoc 'foreign' name ':' schema       {% mkForeignDecl $1 Nothing $3 $5 }
  | mbDoc 'foreign' name name ':' schema  {% mkForeignDecl $1 (Just $3) $4 $6 }
  

parameter_decls         :: { TopDecl PName }
  : 'parameter' 'v{' par_decls 'v}' { mkParDecls (reverse $3) }

-- Reversed
par_decls                            :: { [ParamDecl PName] }
  : par_decl                            { [$1] }
  | par_decls ';'  par_decl             { $3 : $1 }
  | par_decls 'v;' par_decl             { $3 : $1 }

par_decl                         :: { ParamDecl PName }
  : mbDoc        name ':' schema    { mkParFun $1 $2 $4 }
  | mbDoc 'type' name ':' kind      {% mkParType $1 $3 $5 }
  | mbDoc typeOrPropSyn             { mkIfacePropSyn (thing `fmap` $1) $2 }
  | mbDoc topTypeConstraint         { DParameterConstraint (ParameterConstraint (distrLoc $2) $1) }


doc                     :: { Located Text }
  : DOC                    { mkDoc (fmap tokenText $1) }

mbDoc                   :: { Maybe (Located Text) }
  : doc                    { Just $1 }
  | {- empty -}            { Nothing }

decl                    :: { Decl PName }
  : vars_comma ':' schema  { at (head $1,$3) $ DSignature (reverse $1) $3   }
  | ipat '=' expr          { at ($1,$3) $ DPatBind $1 $3                    }
  | '(' op ')' '=' expr    { at ($1,$5) $ DPatBind (PVar $2) $5             }
  | var iapats_indices propguards_cases
                           {% mkPropGuardsDecl $1 $2 $3 }
  | var propguards_cases
                           {% mkConstantPropGuardsDecl $1 $2 }
  | var iapats_indices '=' expr
                           { at ($1,$4) $ mkIndexedDecl $1 $2 $4 }

  | iapat pat_op iapat '=' expr
                           { at ($1,$5) $
                             DBind $ Bind { bName      = $2
                                          , bParams    = PatternParams [$1,$3]
                                          , bDef       = at $5 (Located emptyRange (exprDef $5))
                                          , bSignature = Nothing
                                          , bPragmas   = []
                                          , bMono      = False
                                          , bInfix     = True
                                          , bFixity    = Nothing
                                          , bDoc       = Nothing
                                          , bExport    = Public
                                          } }

  | typeOrPropSyn          { $1 }

  | 'infixl' NUM ops       {% mkFixity LeftAssoc  $2 (reverse $3) }
  | 'infixr' NUM ops       {% mkFixity RightAssoc $2 (reverse $3) }
  | 'infix'  NUM ops       {% mkFixity NonAssoc   $2 (reverse $3) }
  | error                  {% expected "a declaration" }

let_decls               :: { [Decl PName] }
  : let_decl               { [$1] }
  | let_decl ';'           { [$1] }
  | let_decl ';' let_decls { ($1:$3) }

let_decl                :: { Decl PName }
  : 'let' ipat '=' expr               { at ($2,$4) $ DPatBind $2 $4                    }
  | 'let' var iapats_indices '=' expr  { at ($2,$5) $ mkIndexedDecl $2 $3 $5 }
  | 'let' '(' op ')' '=' expr         { at ($2,$6) $ DPatBind (PVar $3) $6             }
  | 'let' iapat pat_op iapat '=' expr
                           { at ($2,$6) $
                             DBind $ Bind { bName      = $3
                                          , bParams    = PatternParams [$2,$4]
                                          , bDef       = at $6 (Located emptyRange (exprDef $6))
                                          , bSignature = Nothing
                                          , bPragmas   = []
                                          , bMono      = False
                                          , bInfix     = True
                                          , bFixity    = Nothing
                                          , bDoc       = Nothing
                                          , bExport    = Public
                                          } }

  | 'let' vars_comma ':' schema  { at (head $2,$4) $ DSignature (reverse $2) $4   }

  | typeOrPropSyn          { $1 }

  | 'infixl' NUM ops       {% mkFixity LeftAssoc  $2 (reverse $3) }
  | 'infixr' NUM ops       {% mkFixity RightAssoc $2 (reverse $3) }
  | 'infix'  NUM ops       {% mkFixity NonAssoc   $2 (reverse $3) }


typeOrPropSyn                      :: { Decl PName }
  : 'type' 'constraint' type '=' type {% mkPropSyn $3 $5 }
  | 'type'              type '=' type {% mkTySyn   $2 $4 }

topTypeConstraint                  :: { Located [Prop PName] }
  : 'type' 'constraint' type          {% mkProp $3 }


propguards_cases                   :: { [PropGuardCase PName] }
  : propguards_cases propguards_case  { $2 : $1 }
  | propguards_case                   { [$1] }

propguards_case                    :: { PropGuardCase PName }
  : '|' propguards_quals '=>' expr    { PropGuardCase $2 $4 }

propguards_quals                   :: { [Located (Prop PName)] }
  : type                              {% mkPropGuards $1 }


newtype                                   :: { Newtype PName }
  : 'newtype' type '=' newtype_body deriving {% mkNewtype $2 $4 $5 }

newtype_body            :: { Located (RecordMap Ident (Range, Type PName)) }
  : '{' '}'                {% mkRecord (rComb $1 $2) (Located emptyRange) [] }
  | '{' field_types '}'    {% mkRecord (rComb $1 $3) (Located emptyRange) $2 }


enum                                :: { EnumDecl PName }
  : 'enum' type '=' enum_body deriving {% mkEnumDecl $2 $4 $5 }

enum_body                         :: { [TopLevel (EnumCon PName)] }
  :     enum_con                     { [$1] }
  | '|' enum_con                     { [$2] }
  | enum_body '|' enum_con           { $3 : $1 }

enum_con                           :: { TopLevel (EnumCon PName) }
  : app_type                          {% mkConDecl Nothing   Public $1 }
  | doc  app_type                     {% mkConDecl (Just $1) Public $2 }

deriving                       :: { [Located PName] }
  : 'deriving' '(' vars_comma ')' { reverse $3 }
  | {- empty -}                   { [] }

vars_comma                 :: { [ LPName ]  }
  : var                       { [ $1]      }
  | vars_comma ',' var        { $3 : $1    }

var                        :: { LPName }
  : name                      { $1 }
  | '(' op ')'                { $2 }

decls                   :: { [Decl PName] }
  : decl ';'               { [$1] }
  | decls decl ';'         { $2 : $1 }

vdecls                  :: { [Decl PName] }
  : decl                   { [$1] }
  | vdecls 'v;' decl       { $3 : $1 }
  | vdecls ';'  decl       { $3 : $1 }

decls_layout            :: { [Decl PName] }
  : 'v{' vdecls 'v}'       { $2 }
  | 'v{' 'v}'              { [] }

repl                    :: { ReplInput PName }
  : expr                   { ExprInput $1 }
  | let_decls              { LetInput $1 }
  | {- empty -}            { EmptyInput }


--------------------------------------------------------------------------------
-- Operators

qop                              :: { LPName }
  : op                              { $1 }
  | QOP                             { let Token (Op (Other ns i)) _ = thing $1
                                       in mkQual (mkModName ns) (mkInfix i) A.<$ $1 }

op                               :: { LPName }
  : pat_op                          { $1 }
  | '#'                             { Located $1 $ mkUnqual $ mkInfix "#" }
  | '@'                             { Located $1 $ mkUnqual $ mkInfix "@" }

pat_op                           :: { LPName }
  : other_op                        { $1 }

    -- special cases for operators that are re-used elsewhere
  | '*'                             { Located $1 $ mkUnqual $ mkInfix "*" }
  | '+'                             { Located $1 $ mkUnqual $ mkInfix "+" }
  | '-'                             { Located $1 $ mkUnqual $ mkInfix "-" }
  | '~'                             { Located $1 $ mkUnqual $ mkInfix "~" }
  | '^^'                            { Located $1 $ mkUnqual $ mkInfix "^^" }
  | '<'                             { Located $1 $ mkUnqual $ mkInfix "<" }
  | '>'                             { Located $1 $ mkUnqual $ mkInfix ">" }

other_op                         :: { LPName }
  : OP                              { let Token (Op (Other [] str)) _ = thing $1
                                       in mkUnqual (mkInfix str) A.<$ $1 }

ops                     :: { [LPName] }
  : op                     { [$1] }
  | ops ',' op             { $3 : $1 }



--------------------------------------------------------------------------------
-- Expressions


expr                          :: { Expr PName }
  : exprNoWhere                  { $1 }
  | expr 'where' whereClause     { at ($1,$3) (EWhere $1 (thing $3)) }

-- | An expression without a `where` clause
exprNoWhere                    :: { Expr PName }
  : simpleExpr qop longRHS        { binOp $1 $2 $3 }
  | longRHS                       { $1 }
  | typedExpr                     { $1 }

whereClause                    :: { Located [Decl PName] }
  : 'v{' 'v}'                     { Located (rComb $1 $2) [] }
  | 'v{' vdecls 'v}'              { let l2 = fromMaybe $3 (getLoc $2)
                                    in Located (rComb $1 l2) (reverse $2) }

-- An expression with a type annotation
typedExpr                      :: { Expr PName }
  : simpleExpr ':' type           { at ($1,$3) (ETyped $1 $3) }

-- A possibly infix expression (no where, no long application, no type annot)
simpleExpr                     :: { Expr PName }
  : simpleExpr qop simpleRHS      { binOp $1 $2 $3 }
  | simpleRHS                     { $1 }

-- An expression without an obvious end marker
longExpr                       :: { Expr PName }
  : 'if' ifBranches 'else' exprNoWhere   { at ($1,$4) $ mkIf (reverse $2) $4 }
  | '\\' iapats '->' exprNoWhere         { at ($1,$4) $ EFun emptyFunDesc (reverse $2) $4 }
  | 'case' expr 'of' 'v{' vcaseBranches 'v}' {at ($1,$6) (ECase $2 (reverse $5))}


ifBranches                     :: { [(Expr PName, Expr PName)] }
  : ifBranch                      { [$1] }
  | ifBranches '|' ifBranch       { $3 : $1 }

ifBranch                       :: { (Expr PName, Expr PName) }
  : expr 'then' expr              { ($1, $3) }

vcaseBranches                  :: { [CaseAlt PName] }
  : caseBranch                    { [$1] }
  | vcaseBranches 'v;' caseBranch { $3 : $1 }
  | vcaseBranches ';'  caseBranch { $3 : $1 }

caseBranch                     :: { CaseAlt PName }
  : cpat '->' expr                { CaseAlt $1 $3 }

simpleRHS                      :: { Expr PName }
  : '-' simpleApp                 { at ($1,$2) (EPrefix PrefixNeg $2) }
  | '~' simpleApp                 { at ($1,$2) (EPrefix PrefixComplement $2) }
  | simpleApp                     { $1 }

longRHS                        :: { Expr PName }
  : '-' longApp                   { at ($1,$2) (EPrefix PrefixNeg $2) }
  | '~' longApp                   { at ($1,$2) (EPrefix PrefixComplement $2) }
  | longApp                       { $1 }


-- Prefix application expression, ends with an atom.
simpleApp                      :: { Expr PName }
  : aexprs                        {% mkEApp $1 }

-- Prefix application expression, may end with a long expression
longApp                        :: { Expr PName }
  : simpleApp longExpr            { at ($1,$2) (EApp $1 $2) }
  | longExpr                      { $1 }
  | simpleApp                     { $1 }

aexprs                         :: { NonEmpty (Expr PName) }
  : aexpr                         { $1 :| [] }
  | aexprs aexpr                  { cons $2 $1 }


-- Expression atom (needs no parens)
aexpr                          :: { Expr PName }
  : no_sel_aexpr                  { $1 }
  | sel_expr                      { $1 }

no_sel_aexpr                   :: { Expr PName                             }
  : qname                         { at $1 $ EVar (thing $1)                }

  | NUM                           { at $1 $ numLit (thing $1)              }
  | FRAC                          { at $1 $ fracLit (thing $1)             }
  | STRLIT                        { at $1 $ ELit $ ECString $ getStr $1    }
  | CHARLIT                       { at $1 $ ELit $ ECChar $ getChr $1      }
  | '_'                           { at $1 $ EVar $ mkUnqual $ mkIdent "_" }

  | '(' expr ')'                  { at ($1,$3) $ EParens $2                }
  | '(' tuple_exprs ')'           { at ($1,$3) $ ETuple (reverse $2)       }
  | '(' ')'                       { at ($1,$2) $ ETuple []                 }
  | '{' '}'                       {% mkRecord (rComb $1 $2) ERecord []     }
  | '{' rec_expr '}'              {% case $2 of {
                                       Left upd -> pure $ at ($1,$3) upd;
                                       Right fs -> mkRecord (rComb $1 $3) ERecord fs; }}
  | '[' ']'                       { at ($1,$2) $ EList []                  }
  | '[' list_expr  ']'            { at ($1,$3) $2                          }
  | '`' tick_ty                   { at ($1,$2) $ ETypeVal $2               }

  | '(' qop ')'                   { at ($1,$3) $ EVar $ thing $2           }

  | '<|'            '|>'          {% mkPoly (rComb $1 $2) [] }
  | '<|' poly_terms '|>'          {% mkPoly (rComb $1 $3) $2 }

sel_expr                       :: { Expr PName }
  : no_sel_aexpr selector         { at ($1,$2) $ ESel $1 (thing $2)   }
  | sel_expr     selector         { at ($1,$2) $ ESel $1 (thing $2)   }

selector                       :: { Located Selector }
  : SELECTOR                      { mkSelector `fmap` $1 }

poly_terms                     :: { [(Bool, Integer)] }
  : poly_term                     { [$1] }
  | poly_terms '+' poly_term      { $3 : $1 }

poly_term                      :: { (Bool, Integer) }
  : NUM                           {% polyTerm (srcRange $1) (getNum $1) 0 }
  | 'x'                           {% polyTerm $1 1 1 }
  | 'x' '^^' NUM                  {% polyTerm (rComb $1 (srcRange $3))
                                                            1 (getNum $3) }
tuple_exprs                    :: { [Expr PName] }
  : expr ',' expr                 { [ $3, $1] }
  | tuple_exprs ',' expr          { $3 : $1   }


rec_expr :: { Either (Expr PName) [Named (Expr PName)] }
  : aexpr '|' field_exprs         { Left (EUpd (recExprWildcardCase $1) (reverse $3)) }
  | field_exprs                   {% Right `fmap` mapM ufToNamed $1 }

field_exprs                    :: { [UpdField PName] }
  : field_expr                    { [$1]    }
  | field_exprs ',' field_expr    { $3 : $1 }

field_expr                     :: { UpdField PName }
  : field_path opt_iapats_indices field_how expr
                                  { UpdField $3 $1 (mkIndexedExpr $2 $4) }

field_path                     :: { [Located Selector] }
  : aexpr                         {% exprToFieldPath $1 }

field_how                      :: { UpdHow }
  : '='                           { UpdSet }
  | '->'                          { UpdFun }


list_expr                      :: { Expr PName }
  : expr '|' list_alts            { EComp $1 (reverse $3)    }
  | expr                          { EList [$1]               }
  | tuple_exprs                   { EList (reverse $1)       }

  {- The `expr` in the four productions that follow should be `type`.
     This, however, leads to ambiguity because the syntax for types and
     expressions overlaps and we need more than 1 look-ahead to resolve what
     is being parsed.  For this reason, we use `expr` temporarily and
     then convert it to the corresponding type in the AST. -}

  | expr          '..' expr       {% eFromTo $2 $1 Nothing   $3 }
  | expr ',' expr '..' expr       {% eFromTo $4 $1 (Just $3) $5 }

  | expr '..' '<' expr            {% eFromToLessThan $2 $1 $4   }
  | expr '..<'    expr            {% eFromToLessThan $2 $1 $3   }

  | expr '..' expr 'by' expr      {% eFromToBy $2 $1 $3 $5 False }
  | expr '..' '<' expr 'by' expr  {% eFromToBy $2 $1 $4 $6 True }
  | expr '..<' expr 'by' expr     {% eFromToBy $2 $1 $3 $5 True }

  | expr '..' expr 'down' 'by' expr     {% eFromToDownBy $2 $1 $3 $6 False }
  | expr '..' '>' expr 'down' 'by' expr {% eFromToDownBy $2 $1 $4 $7 True }
  | expr '..>' expr 'down' 'by' expr    {% eFromToDownBy $2 $1 $3 $6 True }

  | expr '...'                    { EInfFrom $1 Nothing         }
  | expr ',' expr '...'           { EInfFrom $1 (Just $3)       }


list_alts                      :: { [[Match PName]] }
  : matches                       { [ reverse $1 ] }
  | list_alts '|' matches         { reverse $3 : $1 }

matches                        :: { [Match PName] }
  : match                         { [$1] }
  | matches ',' match             { $3 : $1 }

match                          :: { Match PName }
  : itpat '<-' expr               { Match $1 $3 }


--------------------------------------------------------------------------------
-- Generic patterns

pat                            :: { Pattern PName }
  : cpat ':' type                 { at ($1,$3) $ PTyped $1 $3 }
  | cpat                          { $1                        }

cpat                           :: { Pattern PName }
  : cpat '#' cpat                 { at ($1,$3) $ PSplit $1 $3 }
  | qname apats                   { at ($1,$2) $ PCon $1 (reverse $2)   }
  | apat                          { $1                        }

apats                          :: { [Pattern PName] }
  : apat                          { [$1] }
  | apats apat                    { $2 : $1 }

apat                           :: { Pattern PName }
  : qname                         { at $1 (mkPVar $1) }
  | '_'                           { at $1       $ PWild               }
  | '(' ')'                       { at ($1,$2) $ PTuple []            }
  | '(' pat ')'                   { at ($1,$3)   $2                   }
  | '(' tuple_pats ')'            { at ($1,$3) $ PTuple (reverse $2)  }
  | '[' ']'                       { at ($1,$2) $ PList []             }
  | '[' pat ']'                   { at ($1,$3) $ PList [$2]           }
  | '[' tuple_pats ']'            { at ($1,$3) $ PList (reverse $2)   }
  | '{' '}'                       {% mkRecord (rComb $1 $2) PRecord [] }
  | '{' field_pats '}'            {% mkRecord (rComb $1 $3) PRecord $2 }

tuple_pats                     :: { [Pattern PName] }
  : pat ',' pat                   { [$3, $1] }
  | tuple_pats ',' pat            { $3 : $1   }

field_pat                      :: { Named (Pattern PName) }
  : ident '=' pat                 { Named { name = $1, value = $3 } }

field_pats                     :: { [Named (Pattern PName)] }
  : field_pat                     { [$1]    }
  | field_pats ',' field_pat      { $3 : $1 }


-- Irrefutable patterns
itpat                          :: { Pattern PName }
  : ipat ':' type                 { at ($1,$3) $ PTyped $1 $3 }
  | ipat                          { $1                        }

ipat                           :: { Pattern PName }
  : ipat '#' ipat                 { at ($1,$3) $ PSplit $1 $3 }
  | iapat                         { $1                        }

iapat                          :: { Pattern PName }
  : apat                          {% mkIPat $1 }

iapats                         :: { [Pattern PName] }
  : iapat                         { [$1] }
  | iapats iapat                  { $2 : $1 }

indices                 :: { [Pattern PName] }
  : '@' indices1           { $2 }
  | {- empty -}            { [] }

indices1                :: { [Pattern PName] }
  : iapat                  { [$1] }
  | indices1 '@' apat      { $3 : $1 }

iapats_indices          :: { ([Pattern PName], [Pattern PName]) }
  : iapats indices         { ($1, $2) }
  | '@' indices1           { ([], $2) }

opt_iapats_indices      :: { ([Pattern PName], [Pattern PName]) }
  : {- empty -}            { ([],[]) }
  | iapats_indices         { $1 }



--------------------------------------------------------------------------------

schema                         :: { Schema PName }
  : type                          { at $1 $ mkSchema [] [] $1      }
  | schema_vars type              { at ($1,$2) $ mkSchema (thing $1) [] $2 }
  | schema_quals type             { at ($1,$2) $ mkSchema [] (thing $1) $2 }
  | schema_vars schema_quals type { at ($1,$3) $ mkSchema (thing $1)
                                                          (thing $2) $3 }

schema_vars                    :: { Located [TParam PName] }
  : '{' '}'                       { Located (rComb $1 $2) [] }
  | '{' schema_params '}'         { Located (rComb $1 $3) (reverse $2) }

schema_quals                   :: { Located [Prop PName] }
  : schema_quals schema_qual      { at ($1,$2) $ fmap (++ thing $2) $1 }
  | schema_qual                   { $1 }

schema_qual                    :: { Located [Prop PName] }
  : type '=>'                     {% fmap (\x -> at (x,$2) x) (mkProp $1) }

kind                           :: { Located Kind      }
  : '#'                           { Located $1 KNum   }
  | '*'                           { Located $1 KType  }
  | 'Prop'                        { Located $1 KProp  }
  | kind '->' kind                { combLoc KFun $1 $3 }

schema_param                   :: { TParam PName }
  : ident                         {% mkTParam $1 Nothing           }
  | ident ':' kind                {% mkTParam (at ($1,$3) $1) (Just (thing $3)) }

schema_params                    :: { [TParam PName] }
  : schema_param                    { [$1] }
  | schema_params ',' schema_param  { $3 : $1 }

type                           :: { Type PName              }
  : infix_type '->' type          { at ($1,$3) $ TFun $1 $3 }
  | infix_type                    { $1                      }

infix_type                     :: { Type PName }
  : infix_type op app_type        { at ($1,$3) $ TInfix $1 $2 defaultFixity $3 }
  | app_type                      { $1                                         }

app_type                       :: { Type PName }
  : dimensions atype              { at ($1,$2) $ foldr TSeq $2 (reverse (thing $1)) }
  | qname atypes                  { at ($1,head $2)
                                     $ TUser $1 (reverse $2) }
  | atype                         { $1                    }

atype                          :: { Type PName }
  : qname                         { at $1 $ TUser $1 []                }
  | '(' qop ')'                   { at $1 $ TUser $2 []                }
  | NUM                           { at $1 $ TNum  (getNum $1)          }
  | CHARLIT                       { at $1 $ TChar (getChr $1)          }
  | '[' type ']'                  { at ($1,$3) $ TSeq $2 TBit          }
  | '(' ktype ')'                 { at ($1,$3) $2                      }
  | '(' ')'                       { at ($1,$2) $ TTuple []             }
  | '(' tuple_types ')'           { at ($1,$3) $ TTuple  (reverse $2)  }
  | '{' '}'                       {% mkRecord (rComb $1 $2) TRecord [] }
  | '{' field_types '}'           {% mkRecord (rComb $1 $3) TRecord $2 }
  | '_'                           { at $1 TWild                        }

ktype                          :: { Type PName }
  : type ':' kind                 { TParens $1 (Just (thing $3)) }
  | type                          { TParens $1 Nothing }

atypes                         :: { [ Type PName ] }
  : atype                         { [ $1 ]    }
  | atypes atype                  { $2 : $1   }

dimensions                     :: { Located [Type PName]  }
  : '[' type ']'                  { Located (rComb $1 $3) [ $2 ] }
  | dimensions '[' type ']'       { at ($1,$4) (fmap ($3 :) $1)  }

tuple_types                    :: { [Type PName] }
  : type ',' type                 { [ $3, $1] }
  | tuple_types ',' type          { $3 : $1   }

field_type                     :: { Named (Type PName) }
  : ident ':' type                { Named { name = $1, value = $3 } }

field_types                    :: { [Named (Type PName)] }
  : field_type                    { [$1]    }
  | field_types ',' field_type    { $3 : $1 }


ident              :: { Located Ident }
  : IDENT             { let Token (Ident _ str) _ = thing $1
                         in $1 { thing = mkIdent str } }
  | 'x'               { Located { srcRange = $1, thing = mkIdent "x" } }
  | 'private'         { Located { srcRange = $1, thing = mkIdent "private" } }
  | 'as'              { Located { srcRange = $1, thing = mkIdent "as" } }
  | 'hiding'          { Located { srcRange = $1, thing = mkIdent "hiding" } }

name               :: { LPName }
  : ident             { fmap mkUnqual $1 }


smodName                       :: { Located ModName }
  : ident                         { fmap (mkModName . (:[]) . identText) $1 }
  | QIDENT                        { let Token (Ident ns i) _ = thing $1
                                     in mkModName (ns ++ [i]) A.<$ $1 }


modName                        :: { Located ModName }
  : smodName                      { $1 }
  | 'module' smodName             { $2 }

qname                          :: { Located PName }
  : name                          { $1 }
  | QIDENT                        { let Token (Ident ns i) _ = thing $1
                                     in mkQual (mkModName ns) (mkIdent i) A.<$ $1 }

help_name                      :: { Located PName    }
  : qname                         { $1               }
  | qop                           { $1               }
  | '(' qop ')'                   { $2               }

{- The types that can come after a back-tick: either a type demotion,
or an explicit type application. -}
tick_ty                        :: { Type PName }
  : qname                         { at $1 $ TUser $1 []                }
  | NUM                           { at $1 $ TNum  (getNum $1)          }
  | '(' type ')'                  {% validDemotedType (rComb $1 $3) $2 }
  | '{' '}'                       { at ($1,$2) (TTyApp [])             }
  | '{' field_ty_vals '}'         { at ($1,$3) (TTyApp (reverse $2))   }
  | '{' type '}'                  { anonTyApp (getLoc ($1,$3)) [$2]    }
  | '{' tuple_types '}'           { anonTyApp (getLoc ($1,$3)) (reverse $2) }

-- This for explicit type applications (e.g., f ` { front = 3 })
field_ty_val                   :: { Named (Type PName)              }
  : ident '=' type                { Named { name = $1, value = $3 } }

field_ty_vals                  :: { [Named (Type PName)] }
  : field_ty_val                    { [$1]       }
  | field_ty_vals ',' field_ty_val  { $3 : $1    }




{

parseModName :: String -> Maybe ModName
parseModName txt =
  case parseString defaultConfig { cfgModuleScope = False } modName txt of
    Right a -> Just (thing a)
    Left _  -> Nothing

parseImpName :: String -> Maybe (ImpName PName)
parseImpName txt =
  case parseString defaultConfig { cfgModuleScope = False } impName txt of
    Right a -> Just (thing a)
    Left _  -> Nothing

parseHelpName :: String -> Maybe PName
parseHelpName txt =
  case parseString defaultConfig { cfgModuleScope = False } helpName txt of
    Right a -> Just (thing a)
    Left _  -> Nothing

addImplicitIncludes :: Config -> Program PName -> Program PName
addImplicitIncludes cfg (Program ds) =
  Program $ map path (cfgAutoInclude cfg) ++ ds
  where path p = Include Located { srcRange = rng, thing = p }
        rng    = Range { source = cfgSource cfg, from = start, to = start }


parseProgramWith :: Config -> Text -> Either ParseError (Program PName)
parseProgramWith cfg s = case res s of
                          Left err -> Left err
                          Right a  -> Right (addImplicitIncludes cfg a)
  where
  res = parse cfg $ case cfgLayout cfg of
                      Layout   -> programLayout
                      NoLayout -> program

parseModule :: Config -> Text -> Either ParseError [Module PName]
parseModule cfg = parse cfg { cfgModuleScope = True } top_module

parseProgram :: Layout -> Text -> Either ParseError (Program PName)
parseProgram l = parseProgramWith defaultConfig { cfgLayout = l }

parseExprWith :: Config -> Text -> Either ParseError (Expr PName)
parseExprWith cfg = parse cfg { cfgModuleScope = False } expr

parseExpr :: Text -> Either ParseError (Expr PName)
parseExpr = parseExprWith defaultConfig

parseDeclWith :: Config -> Text -> Either ParseError (Decl PName)
parseDeclWith cfg = parse cfg { cfgModuleScope = False } decl

parseDecl :: Text -> Either ParseError (Decl PName)
parseDecl = parseDeclWith defaultConfig

parseDeclsWith :: Config -> Text -> Either ParseError [Decl PName]
parseDeclsWith cfg = parse cfg { cfgModuleScope = ms } decls'
  where (ms, decls') = case cfgLayout cfg of
                         Layout   -> (True, declsLayout)
                         NoLayout -> (False, decls)

parseDecls :: Text -> Either ParseError [Decl PName]
parseDecls = parseDeclsWith defaultConfig

parseLetDeclWith :: Config -> Text -> Either ParseError (Decl PName)
parseLetDeclWith cfg = parse cfg { cfgModuleScope = False } letDecl

parseLetDecl :: Text -> Either ParseError (Decl PName)
parseLetDecl = parseLetDeclWith defaultConfig

parseReplWith :: Config -> Text -> Either ParseError (ReplInput PName)
parseReplWith cfg = parse cfg { cfgModuleScope = False } repl

parseRepl :: Text -> Either ParseError (ReplInput PName)
parseRepl = parseReplWith defaultConfig

parseSchemaWith :: Config -> Text -> Either ParseError (Schema PName)
parseSchemaWith cfg = parse cfg { cfgModuleScope = False } schema

parseSchema :: Text -> Either ParseError (Schema PName)
parseSchema = parseSchemaWith defaultConfig


{- record expressions have a special treatment of the `_` expression.
   These expressions generate record updating functions.
   We have `_` as an identifier for the cases where we parse types as
   expressions, for example `[ 12 .. _ ]`.
-}
recExprWildcardCase :: (Expr PName) -> Maybe (Expr PName)
recExprWildcardCase e =
  case e of
    EVar (UnQual "_") -> Nothing
    _                 -> Just e


-- vim: ft=haskell
}
